Meeting Pearls 4/Meeting Pearls Vol. IV (1996)(GTI - Schatztruhe)[!].iso/Pearls/midi/misc/Midi2TeX/src/tp_heap1.pas

Pascal/Delphi Source File | 1992-04-02 | 9KB | 352 lines

UNIT TP_Heap1;

INTERFACE
uses TP_DECL,
{$IFDEF PC}
     Crt,
{$ENDIF}
     TP_DEBUG;

Procedure Append(VAR ThisList: HeapRecord; N: NoteRecPoint);
Procedure InitNotePool;
Procedure KillNotePool;
Procedure KillNoteLists;
Procedure KillList(VAR ThisList : HeapRecord);
Function  Empty(ThisList:HeapRecord):Boolean;
Procedure InsertOnTop(VAR ThisList: HeapRecord; N : NoteRecPoint);
Procedure Insert(VAR ThisList: HeapRecord; Nin, N: NoteRecPoint);
Procedure Remove(VAR ThisList : HeapRecord; N : NoteRecPoint);
Procedure FirstNote(ThisList:HeapRecord; VAR N:NoteRecPoint);
Procedure LastNote(ThisList:HeapRecord; VAR N : NoteRecPoint);
Procedure NextNote(N:NoteRecPoint; VAR P: NoteRecPoint);
Procedure PrevNote(N:NoteRecPoint; VAR P : NoteRecPoint);
Function  GetFreeNote : NoteRecPoint;
Procedure ResetNoteRec(N : NoteRecPoint);
Procedure BringFreeNote(N:NoteRecPoint);
Function  EqualsNote(N:NoteRecPoint;ThisNote : Byte) : Boolean;
Procedure Exchange(VAR ThisList : HeapRecord;
                   VAR N1, N2 : NoteRecPoint);
Function NoteList2String(ThisList : HeapRecord):String;
Function ChordNoteList2String(ThisList : HeapRecord):String;
IMPLEMENTATION

(**********************************************************)
   Function Empty(ThisList:HeapRecord):Boolean;
(**********************************************************)
Begin
(* Empty:=ThisList.Tail=nil; *) (* does not work properly yet, FIX !! *)
Empty:=ThisList.Size=0;
End;

(********************************************************************)
   Procedure InsertOnTop(VAR ThisList: HeapRecord; N : NoteRecPoint);
(********************************************************************)
Begin
With ThisList Do
   Begin
   if Tail=nil then
      Begin
      Tail:=N; N^.Next:=N;  N^.Prev:=N;
      end
   else
      Begin
      N^.Next:=Tail^.Next; N^.Prev:=Tail;
      Tail^.Next^.Prev:=N;
      Tail^.Next:=N;
      End;
   Inc(Size);
   End;
End;

(**********************************************************)
 Procedure Append(VAR ThisList:HeapRecord; N: NoteRecPoint);
(**********************************************************)
begin
with ThisList do
  Begin
  If Tail=nil Then
    Begin
    Tail:=N;  N^.Next:=N;  N^.Prev:=N;
    End
  Else
    Begin
    N^.Prev:=Tail;
    N^.Next:=Tail^.Next;
    Tail^.Next^.Prev:=N;
    Tail^.Next:=N;
    Tail:=N;
    End;
  Inc(Size);
  End;
end;

(*****************************************************************)
 Procedure Insert(VAR ThisList: HeapRecord; Nin, N: NoteRecPoint);
(* inserts N BEFORE Nin !!                                       *)
(*****************************************************************)
begin
With ThisList Do
  Begin
  if (Tail = nil) then  (* NoteList is empty *)
    InsertOnTop(ThisList,N)
  else
    if Nin=Tail^.Next Then    (* N should be inserted in front of the first item in list ...*)
       (* Append(ThisList,N) *)
       InsertOnTop(ThisList,N)
    else
       Begin
       Nin^.Prev^.Next:=N;
       N^.Prev:=Nin^.Prev;
       Nin^.Prev:=N;
       N^.Next:=Nin;
       Inc(Size);
       End;
  End; (* with *)
end;

(**************************************************************)
  Procedure Remove(VAR ThisList : HeapRecord; N : NoteRecPoint);
(**************************************************************)
var
  P: NoteRecPoint;
begin
with ThisList Do
  Begin
  if Tail <> nil then
   begin
    P := Tail; (* pointer to Tail *)
    while (P^.Next<>N) and (P^.Next <> Tail) do P := P^.Next;
    if P^.Next = N then
      begin
        P^.Next := N^.Next;
        N^.Next^.Prev:=P;
        if Tail= N then if P = N then Tail:= nil else Tail:= N^.Prev;
      end; (* if *)
   end; (* if *)
  Dec(Size);
  end; (* with *)
end;

(*****************************************************)
  Procedure FirstNote(ThisList:HeapRecord; VAR N:NoteRecPoint);
(*****************************************************)
VAR c : CHAR;
Begin
N:=ThisList.Tail^.Next;
If KeyPressed Then
   Begin
   c:=ReadKey;
   if c='q' then ErrorExit(17);
   End;
End;

(*****************************************************)
 Procedure LastNote(ThisList:HeapRecord; VAR N : NoteRecPoint);
(*****************************************************)
VAR  c : CHAR;
Begin
N:=ThisList.Tail;
If KeyPressed Then
   Begin
   c:=ReadKey;
   if c='q' then ErrorExit(17);
   End;
End;

(*****************************************************)
 Procedure NextNote(N:NoteRecPoint; VAR P: NoteRecPoint);
(*****************************************************)
VAR c : CHAR;
Begin
P:=N^.Next;
If KeyPressed Then
   Begin
   c:=ReadKey;
   if c='q' then ErrorExit(17);
   End;
End;

(*****************************************************)
 Procedure PrevNote(N:NoteRecPoint; VAR P : NoteRecPoint);
(*****************************************************)
Begin
 P:=N^.Prev;
End;

(***************************************************)
    Procedure ResetNoteRec(N : NoteRecPoint);
(***************************************************)
 Begin
 FillChar(N^,SizeOf(NoteRecord),0);
 End;


(*****************************************************)
 Function GetFreeNote : NoteRecPoint;
(*****************************************************)
VAR N : NoteRecPoint;
Begin
With NotePool Do
  If Size>0 then
     Begin N:=Tail; Remove(NotePool,N); ResetNoteRec(N); end
  else
     ErrorExit(10);
GetFreeNote:=N;
End;

(*****************************************************)
 Procedure BringFreeNote(N:NoteRecPoint);
(*****************************************************)
Begin
Append(NotePool,N);
End;

(*************************************************************)
 Function EqualsNote(N:NoteRecPoint;ThisNote : Byte) : Boolean;
(*************************************************************)
Begin
If N^.NoteVal=ThisNote then
  EqualsNote:=TRUE
else
  EqualsNote:=FALSE;
End;


(*************************)
  Procedure InitNotePool;
(*************************)
CONST POOLSIZE=200;

VAR
    N  :  NoteRecPoint;

Begin
  for i:=1 to POOLSIZE do
     begin
     If MaxAvail>SizeOf(NoteRecord) Then
         GetMem(N,SizeOf(NoteRecord))
     Else ErrorExit(9);
     Append(NotePool,N);
     end;
End; (* InitNoteHeap *)

(*************************)
  Procedure KillNotePool;
(*************************)
Begin
KillList(NotePool);
End;

(*************************)
  Procedure KillNoteLists;
(*************************)
VAR I : Integer;
Begin
for i:=1to 16 do
  with TrackArray[i] do
     if NoteList.Tail<>NIL Then KillList(NoteList);
KillList(NotePool);
End;


(***********************************************)
  Procedure KillList(VAR ThisList : HeapRecord);
(***********************************************)
VAR
    N,P :  NoteRecPoint;
Begin
LastNote(ThisList,P);
While NOT Empty(ThisList) do
     begin
     N:=P^.Next;
     Remove(ThisList,N);
     FreeMem(N,SizeOf(NoteRecord));
     end;
End; (* InitNoteHeap *)


(***********************************************************)
    Function NoteList2String(ThisList : HeapRecord):String;
(***********************************************************)
Var Tmpstr,tmp : String;
    N,P        : NoteRecPoint;
Begin
N:=ThisList.Tail^.Next;
P:=N;
Tmpstr:='';
Repeat
   Case N^.Event OF
        NOTEON,NOTEOFF : Begin
                         Str(N^.NoteVal,tmp);
                         TmpStr:=Tmpstr+tmp+' ';
                         End;
        Else TmpStr:=Tmpstr+'n ';
        End;
   NextNote(N,N)
until N=P;
NoteList2String:=TmpStr;
End;

(***********************************************************)
    Function ChordNoteList2String(ThisList : HeapRecord):String;
(***********************************************************)
Var Tmpstr,tmp : String;
    N,P        : NoteRecPoint;
Begin
N:=ThisList.Tail^.Next;
P:=N;
Tmpstr:='';
Repeat
   Case N^.Event OF
        NOTEON,NOTEOFF : Begin
                         Str(N^.NoteVal,tmp);
                         If N^.ChordNote Then
                            TmpStr:=Tmpstr+'-- '
                         Else
                            TmpStr:=Tmpstr+tmp+' ';
                         End;
        Else TmpStr:=Tmpstr+'n ';
        End;
   NextNote(N,N)
until N=P;
ChordNoteList2String:=TmpStr;
End;

(*************************************************)
  Procedure Exchange(VAR ThisList : HeapRecord;
                     VAR N1, N2 : NoteRecPoint);
(*************************************************)
Var P1,P2,F : NoteRecPoint;
Begin
F:=ThisList.Tail^.Next; (* first item in notelist *)
NextNote(N1,P1);
NextNote(N2,P2);
If P1=N2 Then
  If P2=N1 Then (* only two notes in the list *)
    With ThisList Do NextNote(Tail,Tail)
  Else
    Begin
    Remove(ThisList,N2);
    (*If N1=F Then Append(ThisList,N2) Else *)
    Insert(ThisList,N1,N2);
    Remove(ThisList,N1);
    If P2=F Then Append(ThisList,N1) Else Insert(ThisList,P2,N1);
    End
Else
   Begin
   Remove(ThisList,N1);
   (* If N2=F Then Append(ThisList,N1) Else *)
   Insert(ThisList,N2,N1);
   Remove(ThisList,N2);
   If P1=F Then Append(ThisList,N2) Else Insert(ThisList,P1,N2);
   End;
End; (* exchange *)


Begin
NotePool.Tail:=nil;
NotePool.Size:=0;
For i:=1 to 16 do with TrackArray[i].NoteList do
  Begin Size:=0; Tail:=NIL; End;
End.